home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / universal.c < prev    next >
C/C++ Source or Header  |  1998-07-19  |  5KB  |  219 lines
  1. #include "EXTERN.h"
  2. #include "perl.h"
  3.  
  4. /*
  5.  * Contributed by Graham Barr  <Graham.Barr@tiuk.ti.com>
  6.  * The main guts of traverse_isa was actually copied from gv_fetchmeth
  7.  */
  8.  
  9. STATIC SV *
  10. isa_lookup(HV *stash, char *name, int len, int level)
  11. {
  12.     AV* av;
  13.     GV* gv;
  14.     GV** gvp;
  15.     HV* hv = Nullhv;
  16.  
  17.     if (!stash)
  18.     return &PL_sv_undef;
  19.  
  20.     if(strEQ(HvNAME(stash), name))
  21.     return &PL_sv_yes;
  22.  
  23.     if (level > 100)
  24.     croak("Recursive inheritance detected in package '%s'", HvNAME(stash));
  25.  
  26.     gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
  27.  
  28.     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv))) {
  29.     SV* sv;
  30.     SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
  31.     if (svp && (sv = *svp) != (SV*)&PL_sv_undef)
  32.         return sv;
  33.     }
  34.  
  35.     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  36.     
  37.     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
  38.     if(!hv) {
  39.         gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
  40.  
  41.         gv = *gvp;
  42.  
  43.         if (SvTYPE(gv) != SVt_PVGV)
  44.         gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
  45.  
  46.         hv = GvHVn(gv);
  47.     }
  48.     if(hv) {
  49.         SV** svp = AvARRAY(av);
  50.         /* NOTE: No support for tied ISA */
  51.         I32 items = AvFILLp(av) + 1;
  52.         while (items--) {
  53.         SV* sv = *svp++;
  54.         HV* basestash = gv_stashsv(sv, FALSE);
  55.         if (!basestash) {
  56.             if (PL_dowarn)
  57.             warn("Can't locate package %s for @%s::ISA",
  58.                 SvPVX(sv), HvNAME(stash));
  59.             continue;
  60.         }
  61.         if(&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
  62.             (void)hv_store(hv,name,len,&PL_sv_yes,0);
  63.             return &PL_sv_yes;
  64.         }
  65.         }
  66.         (void)hv_store(hv,name,len,&PL_sv_no,0);
  67.     }
  68.     }
  69.  
  70.     return boolSV(strEQ(name, "UNIVERSAL"));
  71. }
  72.  
  73. bool
  74. sv_derived_from(SV *sv, char *name)
  75. {
  76.     SV *rv;
  77.     char *type;
  78.     HV *stash;
  79.   
  80.     stash = Nullhv;
  81.     type = Nullch;
  82.  
  83.     if (SvGMAGICAL(sv))
  84.         mg_get(sv) ;
  85.  
  86.     if (SvROK(sv)) {
  87.         sv = SvRV(sv);
  88.         type = sv_reftype(sv,0);
  89.         if(SvOBJECT(sv))
  90.             stash = SvSTASH(sv);
  91.     }
  92.     else {
  93.         stash = gv_stashsv(sv, FALSE);
  94.     }
  95.  
  96.     return (type && strEQ(type,name)) ||
  97.             (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
  98.         ? TRUE
  99.         : FALSE ;
  100.  
  101. }
  102.  
  103. #ifdef PERL_OBJECT
  104. #define NO_XSLOCKS
  105. #endif  /* PERL_OBJECT */
  106.  
  107. #include "XSUB.h"
  108.  
  109. static
  110. XS(XS_UNIVERSAL_isa)
  111. {
  112.     dXSARGS;
  113.     SV *sv;
  114.     char *name;
  115.  
  116.     if (items != 2)
  117.     croak("Usage: UNIVERSAL::isa(reference, kind)");
  118.  
  119.     sv = ST(0);
  120.     name = (char *)SvPV(ST(1),PL_na);
  121.  
  122.     ST(0) = boolSV(sv_derived_from(sv, name));
  123.     XSRETURN(1);
  124. }
  125.  
  126. static
  127. XS(XS_UNIVERSAL_can)
  128. {
  129.     dXSARGS;
  130.     SV   *sv;
  131.     char *name;
  132.     SV   *rv;
  133.     HV   *pkg = NULL;
  134.  
  135.     if (items != 2)
  136.     croak("Usage: UNIVERSAL::can(object-ref, method)");
  137.  
  138.     sv = ST(0);
  139.     name = (char *)SvPV(ST(1),PL_na);
  140.     rv = &PL_sv_undef;
  141.  
  142.     if(SvROK(sv)) {
  143.         sv = (SV*)SvRV(sv);
  144.         if(SvOBJECT(sv))
  145.             pkg = SvSTASH(sv);
  146.     }
  147.     else {
  148.         pkg = gv_stashsv(sv, FALSE);
  149.     }
  150.  
  151.     if (pkg) {
  152.         GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
  153.         if (gv && isGV(gv))
  154.         rv = sv_2mortal(newRV((SV*)GvCV(gv)));
  155.     }
  156.  
  157.     ST(0) = rv;
  158.     XSRETURN(1);
  159. }
  160.  
  161. static
  162. XS(XS_UNIVERSAL_VERSION)
  163. {
  164.     dXSARGS;
  165.     HV *pkg;
  166.     GV **gvp;
  167.     GV *gv;
  168.     SV *sv;
  169.     char *undef;
  170.     double req;
  171.  
  172.     if(SvROK(ST(0))) {
  173.         sv = (SV*)SvRV(ST(0));
  174.         if(!SvOBJECT(sv))
  175.             croak("Cannot find version of an unblessed reference");
  176.         pkg = SvSTASH(sv);
  177.     }
  178.     else {
  179.         pkg = gv_stashsv(ST(0), FALSE);
  180.     }
  181.  
  182.     gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
  183.  
  184.     if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (sv = GvSV(gv))) {
  185.         SV *nsv = sv_newmortal();
  186.         sv_setsv(nsv, sv);
  187.         sv = nsv;
  188.         undef = Nullch;
  189.     }
  190.     else {
  191.         sv = (SV*)&PL_sv_undef;
  192.         undef = "(undef)";
  193.     }
  194.  
  195.     if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv))))
  196.     croak("%s version %s required--this is only version %s",
  197.           HvNAME(pkg), SvPV(ST(1),PL_na), undef ? undef : SvPV(sv,PL_na));
  198.  
  199.     ST(0) = sv;
  200.  
  201.     XSRETURN(1);
  202. }
  203.  
  204. #ifdef PERL_OBJECT
  205. #undef  boot_core_UNIVERSAL
  206. #define boot_core_UNIVERSAL CPerlObj::Perl_boot_core_UNIVERSAL
  207. #define pPerl this
  208. #endif
  209.  
  210. void
  211. boot_core_UNIVERSAL(void)
  212. {
  213.     char *file = __FILE__;
  214.  
  215.     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
  216.     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
  217.     newXS("UNIVERSAL::VERSION",     XS_UNIVERSAL_VERSION,       file);
  218. }
  219.